home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / xlisp2.1 / xldist02.zoo / sources / xlread.c < prev    next >
Encoding:
C/C++ Source or Header  |  1990-11-09  |  18.0 KB  |  949 lines
  1. /* xlread - xlisp expression input routine */
  2. /*        Copyright (c) 1985, by David Michael Betz
  3.         All Rights Reserved
  4.         Permission is granted for unrestricted non-commercial use        */
  5.  
  6. #include "xlisp.h"
  7. #include <string.h>
  8. #include <stdlib.h>
  9.  
  10. /* symbol parser modes */
  11. #define DONE    0
  12. #define NORMAL    1
  13. #define ESCAPE    2
  14.  
  15. /* external variables */
  16. extern LVAL true,s_dot;
  17. extern LVAL s_quote,s_function,s_bquote,s_comma,s_comat;
  18. extern LVAL s_rtable,k_wspace,k_const,k_nmacro,k_tmacro;
  19. extern LVAL k_sescape,k_mescape;
  20. extern char buf[];
  21.  
  22. /* string constants */
  23. #define WSPACE "\t \f\r\n"
  24. #define CONST1 "!$%&*+-./0123456789:<=>?@[]^_{}~"
  25. #define CONST2 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"
  26.  
  27.  
  28. /* forward declarations */
  29. #ifdef ANSI
  30. LVAL callmacro(LVAL fptr, int ch);
  31. LVAL psymbol(LVAL fptr);
  32. LVAL punintern(LVAL fptr);
  33. LVAL pnumber(LVAL fptr, int radix);
  34. LVAL pquote(LVAL fptr, LVAL sym);
  35. LVAL plist(LVAL fptr);
  36. LVAL pvector(LVAL fptr);
  37. #ifdef STRUCTS
  38. LVAL pstruct(LVAL fptr);
  39. #endif
  40. LVAL readlist(LVAL fptr, int *plen);
  41. void pcomment(LVAL fptr);
  42. void badeof(LVAL fptr);
  43. void upcase(char *str);
  44. int  storech(char *buf, int c, int ch);
  45. int  nextch(LVAL fptr);
  46. int  checkeof(LVAL fptr);
  47. int  readone(LVAL fptr, LVAL *pval);
  48. int  pname(LVAL fptr, int *pescflag);
  49. #else
  50. FORWARD LVAL callmacro();
  51. FORWARD LVAL psymbol(),punintern();
  52. FORWARD LVAL pnumber(),pquote(),plist(),pvector();
  53. #ifdef STRUCTS
  54. FORWARD LVAL pstruct();
  55. #endif
  56. FORWARD LVAL readlist();
  57. FORWARD VOID pcomment();
  58. FORWARD VOID badeof();
  59. FORWARD VOID upcase();
  60. #endif
  61.  
  62. #ifdef MSC6
  63. /* no optimization which interferes with setjmp */
  64. #pragma optimize("elg",off)
  65. #endif
  66.  
  67. /* xlload - load a file of xlisp expressions */
  68. int xlload(fname,vflag,pflag)
  69.   char *fname; int vflag,pflag;
  70. {
  71.     char fullname[STRMAX+1];
  72.     LVAL fptr,expr;
  73.     CONTEXT cntxt;
  74.     FILE *fp;
  75.     int sts;
  76.  
  77.     /* protect some pointers */
  78.     xlstkcheck(2);
  79.     xlsave(fptr);
  80.     xlsave(expr);
  81.  
  82.     /* default the extension */
  83.     if (needsextension(fname)) {
  84.         strcpy(fullname,fname);
  85.         strcat(fullname,".lsp");
  86.         fname = fullname;
  87.     }
  88.  
  89.     /* allocate a file node */
  90.     fptr = cvfile(NULL);
  91.  
  92.     /* open the file */
  93.     if ((fp = osaopen(fname,"r")) == NULL) {
  94.         xlpopn(2);
  95.         return (FALSE);
  96.     }
  97.     setfile(fptr,fp);
  98.  
  99.     /* print the information line */
  100.     if (vflag)
  101.         { sprintf(buf,"; loading \"%s\"\n",fname); stdputstr(buf); }
  102.  
  103.     /* read, evaluate and possibly print each expression in the file */
  104.     xlbegin(&cntxt,CF_ERROR,true);
  105.     if (setjmp(cntxt.c_jmpbuf))
  106.         sts = FALSE;
  107.     else {
  108.         while (xlread(fptr,&expr)) {
  109.             expr = xleval(expr);
  110.             if (pflag)
  111.                 stdprint(expr);
  112.         }
  113.         sts = TRUE;
  114.     }
  115.     xlend(&cntxt);
  116.  
  117.     /* close the file */
  118.     osclose(getfile(fptr));
  119.     setfile(fptr,NULL);
  120.  
  121.     /* restore the stack */
  122.     xlpopn(2);
  123.  
  124.     /* return status */
  125.     return (sts);
  126. }
  127.  
  128. #ifdef MSC6
  129. #pragma optimize("",on)
  130. #endif
  131.  
  132.  
  133. /* xlread - read an xlisp expression */
  134. int xlread(fptr,pval)
  135.   LVAL fptr,*pval;
  136. {
  137.     int sts;
  138.  
  139.     /* read an expression */
  140.     while ((sts = readone(fptr,pval)) == FALSE)
  141.         ;
  142.  
  143.     /* return status */
  144.     return (sts == EOF ? FALSE : TRUE);
  145. }
  146.  
  147. /* readone - attempt to read a single expression */
  148. LOCAL int readone(fptr,pval)
  149.   LVAL fptr,*pval;
  150. {
  151.     LVAL val,type;
  152.     int ch;
  153.  
  154.     /* get a character and check for EOF */
  155.     if ((ch = xlgetc(fptr)) == EOF)
  156.         return (EOF);
  157.  
  158.     /* handle white space */
  159.     if ((type = tentry(ch)) == k_wspace)
  160.         return (FALSE);
  161.  
  162.     /* handle symbol constituents */
  163.     /* handle single and multiple escapes */  /* combined by TAA MOD */
  164.     else if (type == k_const ||
  165.              type == k_sescape || type == k_mescape) {
  166.         xlungetc(fptr,ch);
  167.         *pval = psymbol(fptr);
  168.         return (TRUE);        
  169.     }
  170.  
  171.     /* handle read macros */
  172.     else if (consp(type)) {
  173.         if (((val = callmacro(fptr,ch)) != 0) && consp(val)) {
  174.             *pval = car(val);
  175.             return (TRUE);
  176.         }
  177.         else
  178.             return (FALSE);
  179.     }
  180.  
  181.     /* handle illegal characters */
  182.     else {
  183. /*        xlerror("illegal character",cvfixnum((FIXTYPE)ch)); */
  184.         xlerror("illegal character",cvchar(ch));    /* friendlier TAA MOD*/
  185.         return (0);     /* compiler warning */
  186.     }
  187. }
  188.  
  189. /* rmhash - read macro for '#' */
  190. LVAL rmhash()
  191. {
  192.     LVAL fptr,val;
  193.     char *bufp;            /* TAA fix to allow control character literals */
  194.         int i;
  195.     int ch;
  196.  
  197.     /* protect some pointers */
  198.     xlsave1(val);
  199.  
  200.     /* get the file and macro character */
  201.     fptr = xlgetfile();
  202.     xlgachar();
  203.     xllastarg();
  204.  
  205.     /* make the return value */
  206.     val = consa(NIL);
  207.  
  208.     /* check the next character */
  209.     switch (ch = xlgetc(fptr)) {
  210.     case '\'':
  211.         rplaca(val,pquote(fptr,s_function));
  212.         break;
  213.     case '(':
  214.         xlungetc(fptr,ch);
  215.         rplaca(val,pvector(fptr));
  216.         break;
  217.  
  218.     case '.':
  219.         
  220.         readone(fptr,&car(val));
  221.         rplaca(val,xleval(car(val)));
  222.         break;
  223.  
  224.     case 'b':
  225.     case 'B':
  226.         rplaca(val,pnumber(fptr,2));
  227.         break;
  228.     case 'o':
  229.     case 'O':
  230.         rplaca(val,pnumber(fptr,8));
  231.         break;
  232.     case 'x':
  233.     case 'X':
  234.         rplaca(val,pnumber(fptr,16));
  235.         break;
  236. #ifdef STRUCTS
  237.     case 's':
  238.     case 'S':
  239.         rplaca(val,pstruct(fptr));
  240.         break;
  241. #endif
  242.     case '\\':
  243.         for (i = 0; i < STRMAX-1; i++) {
  244.             if ((tentry(buf[i] = checkeof(fptr))  != k_const) &&
  245.                 (i > 0) &&        /* TAA fix for left and right paren */
  246.                 buf[i] != '\\' && buf[i] != '|') {
  247.                 xlungetc(fptr, buf[i]);
  248.                 break;
  249.             }
  250.         }
  251.         buf[i] = 0;
  252.         ch = buf[0];
  253.         if (strlen(buf) > 1) {    /* TAA Fixed */
  254.             upcase(buf);
  255.             bufp = &buf[0];
  256.             ch = 0;
  257.             if (strncmp(bufp,"M-",2) == 0) {
  258.                 ch = 128;
  259.                 bufp += 2;
  260.             }
  261.             if (strcmp(bufp,"NEWLINE") == 0)
  262.                 ch += '\n';
  263.             else if (strcmp(bufp,"SPACE") == 0)
  264.                 ch += ' ';
  265.             else if (strcmp(bufp,"RUBOUT") == 0)
  266.                 ch += 127;
  267.             else if (strlen(bufp) == 1) 
  268.                 ch += *bufp;
  269.             else if (strncmp(bufp,"C-",2) == 0 && strlen(bufp) == 3) 
  270.                 ch += bufp[2] & 31;
  271.             else xlerror("unknown character name",cvstring(buf));
  272.         }
  273.         rplaca(val,cvchar(ch));
  274.         break;
  275.     case ':':
  276.         rplaca(val,punintern(fptr));
  277.         break;
  278.     case '|':
  279.         pcomment(fptr);
  280.         val = NIL;
  281.         break;
  282.     default:
  283. /*        xlerror("illegal character after #",cvfixnum((FIXTYPE)ch)); */
  284.         xlerror("illegal character after #",cvchar(ch)); /*TAA Mod */
  285.     }
  286.  
  287.     /* restore the stack */
  288.     xlpop();
  289.  
  290.     /* return the value */
  291.     return (val);
  292. }
  293.  
  294. /* rmquote - read macro for '\'' */
  295. LVAL rmquote()
  296. {
  297.     LVAL fptr;
  298.  
  299.     /* get the file and macro character */
  300.     fptr = xlgetfile();
  301.     xlgachar();
  302.     xllastarg();
  303.  
  304.     /* parse the quoted expression */
  305.     return (consa(pquote(fptr,s_quote)));
  306. }
  307.  
  308. /* rmdquote - read macro for '"' */
  309. LVAL rmdquote()
  310. {
  311.     char buf[STRMAX+1],*p,*sptr;
  312.     LVAL fptr,str,newstr;
  313.     int len,blen,ch,d2,d3;
  314.  
  315.     /* protect some pointers */
  316.     xlsave1(str);
  317.  
  318.     /* get the file and macro character */
  319.     fptr = xlgetfile();
  320.     xlgachar();
  321.     xllastarg();
  322.  
  323.     /* loop looking for a closing quote */
  324.     len = blen = 0; p = buf;
  325.     while ((ch = checkeof(fptr)) != '"') {
  326.  
  327.         /* handle escaped characters */
  328.         switch (ch) {
  329.         case '\\':
  330.                 switch (ch = checkeof(fptr)) {
  331.                 case 't':
  332.                         ch = '\011';
  333.                         break;
  334.                 case 'n':
  335.                         ch = '\012';
  336.                         break;
  337.                 case 'f':
  338.                         ch = '\014';
  339.                         break;
  340.                 case 'r':
  341.                         ch = '\015';
  342.                         break;
  343.                 default:
  344.                         if (ch >= '0' && ch <= '7') {
  345.                             d2 = checkeof(fptr);
  346.                             d3 = checkeof(fptr);
  347.                             if (d2 < '0' || d2 > '7'
  348.                              || d3 < '0' || d3 > '7')
  349.                                 xlfail("invalid octal digit");
  350.                             ch -= '0'; d2 -= '0'; d3 -= '0';
  351.                             ch = (ch << 6) | (d2 << 3) | d3;
  352.                         }
  353.                         break;
  354.                 }
  355.         }
  356.  
  357.  
  358.         /* check for buffer overflow */
  359.  
  360.         if (blen >= STRMAX) {
  361.             newstr = newstring(len + STRMAX + 1);
  362.             sptr = getstring(newstr); 
  363.                 if (str) memcpy((char *)sptr,(char *)getstring(str),len);
  364.             *p = '\0'; 
  365.                 memcpy((char *)sptr+len,(char *)buf,blen+1);
  366.             p = buf; 
  367.                 blen = 0;
  368.             len += STRMAX;
  369.             str = newstr;
  370.         }
  371.  
  372.  
  373.         /* store the character */
  374.         *p++ = ch; ++blen;
  375.     }
  376.  
  377.     /* append the last substring */
  378.  
  379.     if (str == NIL || blen) {
  380.         newstr = newstring(len + blen + 1);
  381.         sptr = getstring(newstr);
  382.         if (str) memcpy((char *)sptr,(char *)getstring(str),len);
  383.         *p = '\0'; 
  384.         memcpy((char *)sptr+len,(char *)buf,blen+1);
  385.         str = newstr;
  386.     }
  387.  
  388.  
  389.     /* restore the stack */
  390.     xlpop();
  391.  
  392.     /* return the new string */
  393.     return (consa(str));
  394. }
  395.  
  396. /* rmbquote - read macro for '`' */
  397. LVAL rmbquote()
  398. {
  399.     LVAL fptr;
  400.  
  401.     /* get the file and macro character */
  402.     fptr = xlgetfile();
  403.     xlgachar();
  404.     xllastarg();
  405.  
  406.     /* parse the quoted expression */
  407.     return (consa(pquote(fptr,s_bquote)));
  408. }
  409.  
  410. /* rmcomma - read macro for ',' */
  411. LVAL rmcomma()
  412. {
  413.     LVAL fptr,sym;
  414.     int ch;
  415.  
  416.     /* get the file and macro character */
  417.     fptr = xlgetfile();
  418.     xlgachar();
  419.     xllastarg();
  420.  
  421.     /* check the next character */
  422.     if ((ch = xlgetc(fptr)) == '@')
  423.         sym = s_comat;
  424.     else {
  425.         xlungetc(fptr,ch);
  426.         sym = s_comma;
  427.     }
  428.  
  429.     /* make the return value */
  430.     return (consa(pquote(fptr,sym)));
  431. }
  432.  
  433. /* rmlpar - read macro for '(' */
  434. LVAL rmlpar()
  435. {
  436.     LVAL fptr;
  437.  
  438.     /* get the file and macro character */
  439.     fptr = xlgetfile();
  440.     xlgachar();
  441.     xllastarg();
  442.  
  443.     /* make the return value */
  444.     return (consa(plist(fptr)));
  445. }
  446.  
  447. /* rmrpar - read macro for ')' */
  448. LVAL rmrpar()
  449. {
  450.     xlfail("misplaced right paren");
  451.     return (NIL);    /* never returns */
  452. }
  453.  
  454. /* rmsemi - read macro for ';' */
  455. LVAL rmsemi()
  456. {
  457.     LVAL fptr;
  458.     int ch;
  459.  
  460.     /* get the file and macro character */
  461.     fptr = xlgetfile();
  462.     xlgachar();
  463.     xllastarg();
  464.  
  465.     /* skip to end of line */
  466.     while ((ch = xlgetc(fptr)) != EOF && ch != '\n')
  467.         ;
  468.  
  469.     /* return nil (nothing read) */
  470.     return (NIL);
  471. }
  472.  
  473. /* pcomment - parse a comment delimited by #| and |# */
  474. LOCAL VOID pcomment(fptr)
  475.   LVAL fptr;
  476. {
  477.     int lastch,ch,n;
  478.  
  479.     /* look for the matching delimiter (and handle nesting) */
  480.     for (n = 1, lastch = -1; n > 0 && (ch = xlgetc(fptr)) != EOF; ) {
  481.         if (lastch == '|' && ch == '#')
  482.             { --n; ch = -1; }
  483.         else if (lastch == '#' && ch == '|')
  484.             { ++n; ch = -1; }
  485.         lastch = ch;
  486.     }
  487. }
  488.  
  489. /* pnumber - parse a number */
  490. LOCAL LVAL pnumber(fptr,radix)
  491.   LVAL fptr; int radix;
  492. {
  493.     int digit,ch;
  494.     long num;
  495.     
  496.     for (num = 0L; (ch = xlgetc(fptr)) != EOF; ) {
  497.         if (islower(ch)) ch = toupper(ch);
  498.         if (!('0' <= ch && ch <= '9') && !('A' <= ch && ch <= 'F'))
  499.             break;
  500.         if ((digit = (ch <= '9' ? ch - '0' : ch - 'A' + 10)) >= radix)
  501.             break;
  502.         num = num * (long)radix + (long)digit;
  503.     }
  504.     xlungetc(fptr,ch);
  505.     return (cvfixnum((FIXTYPE)num));
  506. }
  507.  
  508. /* plist - parse a list */
  509. LOCAL LVAL plist(fptr)
  510.   LVAL fptr;
  511. {
  512.     LVAL val,expr,lastnptr,nptr;
  513.  
  514.     /* protect some pointers */
  515.     xlstkcheck(2);
  516.     xlsave(val);
  517.     xlsave(expr);
  518.  
  519.     /* keep appending nodes until a closing paren is found */
  520.     for (lastnptr = NIL; nextch(fptr) != ')'; )
  521.  
  522.         /* get the next expression */
  523.         switch (readone(fptr,&expr)) {
  524.         case EOF:
  525.             badeof(fptr);
  526.         case TRUE:
  527.  
  528.             /* check for a dotted tail */
  529.             if (expr == s_dot) {
  530.  
  531.                 /* make sure there's a node */
  532.                 if (lastnptr == NIL)
  533.                     xlfail("invalid dotted pair");
  534.  
  535.                 /* parse the expression after the dot */
  536.                 if (!xlread(fptr,&expr))
  537.                     badeof(fptr);
  538.                 rplacd(lastnptr,expr);
  539.  
  540.                 /* make sure its followed by a close paren */
  541.                 if (nextch(fptr) != ')')
  542.                     xlfail("invalid dotted pair");
  543.             }
  544.  
  545.             /* otherwise, handle a normal list element */
  546.             else {
  547.                 nptr = consa(expr);
  548.                 if (lastnptr == NIL)
  549.                     val = nptr;
  550.                 else
  551.                     rplacd(lastnptr,nptr);
  552.                 lastnptr = nptr;
  553.             }
  554.             break;
  555.         }
  556.  
  557.     /* skip the closing paren */
  558.     xlgetc(fptr);
  559.  
  560.     /* restore the stack */
  561.     xlpopn(2);
  562.  
  563.     /* return successfully */
  564.     return (val);
  565. }
  566.  
  567. /* pvector - parse a vector */
  568. LOCAL LVAL pvector(fptr)
  569.  LVAL fptr;
  570. {
  571.     LVAL list,val;
  572.     int len,i;
  573.  
  574.     /* protect some pointers */
  575.     xlsave1(list);
  576.  
  577.     /* read the list */
  578.     list = readlist(fptr,&len);
  579.  
  580.     /* make a vector of the appropriate length */
  581.     val = newvector(len);
  582.  
  583.     /* copy the list into the vector */
  584.     for (i = 0; i < len; ++i, list = cdr(list))
  585.         setelement(val,i,car(list));
  586.  
  587.     /* restore the stack */
  588.     xlpop();
  589.  
  590.     /* return successfully */
  591.     return (val);
  592. }
  593.  
  594. #ifdef STRUCTS
  595. /* pstruct - parse a structure */
  596. LOCAL LVAL pstruct(fptr)
  597.  LVAL fptr;
  598. {
  599.     LVAL list,val;
  600.     int len;
  601.  
  602.     /* protect some pointers */
  603.     xlsave1(list);
  604.  
  605.     /* read the list */
  606.     list = readlist(fptr,&len);
  607.  
  608.     /* make the structure */
  609.     val = xlrdstruct(list);
  610.  
  611.     /* restore the stack */
  612.     xlpop();
  613.  
  614.     /* return successfully */
  615.     return (val);
  616. }
  617. #endif
  618.  
  619. /* pquote - parse a quoted expression */
  620. LOCAL LVAL pquote(fptr,sym)
  621.   LVAL fptr,sym;
  622. {
  623.     LVAL val,p;
  624.  
  625.     /* protect some pointers */
  626.     xlsave1(val);
  627.  
  628.     /* allocate two nodes */
  629.     val = consa(sym);
  630.     rplacd(val,consa(NIL));
  631.  
  632.     /* initialize the second to point to the quoted expression */
  633.     if (!xlread(fptr,&p))
  634.         badeof(fptr);
  635.     rplaca(cdr(val),p);
  636.  
  637.     /* restore the stack */
  638.     xlpop();
  639.  
  640.     /* return the quoted expression */
  641.     return (val);
  642. }
  643.  
  644. /* psymbol - parse a symbol name */
  645. LOCAL LVAL psymbol(fptr)
  646.   LVAL fptr;
  647. {
  648.     int escflag;
  649.     LVAL val;
  650.     pname(fptr,&escflag);
  651.     return (escflag || !isnumber(buf,&val) ? xlenter(buf) : val);
  652. }
  653.  
  654. /* punintern - parse an uninterned symbol */
  655. LOCAL LVAL punintern(fptr)
  656.   LVAL fptr;
  657. {
  658.     int escflag;
  659.     pname(fptr,&escflag);
  660.     return (xlmakesym(buf));
  661. }
  662.  
  663. /* pname - parse a symbol/package name */
  664. #ifdef ANSI
  665. static int pname(LVAL fptr, int *pescflag)
  666. #else
  667. LOCAL int pname(fptr,pescflag)
  668.   LVAL fptr; int *pescflag;
  669. #endif
  670. {
  671.     int mode,ch,i;
  672.     LVAL type;
  673.  
  674.     /* initialize */
  675.     *pescflag = FALSE;
  676.     mode = NORMAL;
  677.     i = 0;
  678.  
  679.     /* accumulate the symbol name */
  680.     while (mode != DONE) {
  681.  
  682.         /* handle normal mode */
  683.         while (mode == NORMAL)
  684.             if ((ch = xlgetc(fptr)) == EOF)
  685.                 mode = DONE;
  686.             else if ((type = tentry(ch)) == k_sescape) {
  687.                 i = storech(buf,i,checkeof(fptr));
  688.                 *pescflag = TRUE;
  689.             }
  690.             else if (type == k_mescape) {
  691.                 *pescflag = TRUE;
  692.                 mode = ESCAPE;
  693.             }
  694.             else if (type == k_const
  695.                  ||     (consp(type) && car(type) == k_nmacro))
  696.                 i = storech(buf,i,islower(ch) ? toupper(ch) : ch);
  697.             else
  698.                 mode = DONE;
  699.  
  700.         /* handle multiple escape mode */
  701.         while (mode == ESCAPE)
  702.             if ((ch = xlgetc(fptr)) == EOF)
  703.                 badeof(fptr);
  704.             else if ((type = tentry(ch)) == k_sescape)
  705.                 i = storech(buf,i,checkeof(fptr));
  706.             else if (type == k_mescape)
  707.                 mode = NORMAL;
  708.             else
  709.                 i = storech(buf,i,ch);
  710.     }
  711.     buf[i] = 0;
  712.  
  713.     /* check for a zero length name */
  714.     if (i == 0)
  715.         xlerror("zero length name", NIL);        /* TAA fix */
  716.  
  717.     /* unget the last character and return it */
  718.     xlungetc(fptr,ch);
  719.     return (ch);
  720. }
  721.  
  722. /* readlist - read a list terminated by a ')' */
  723. LOCAL LVAL readlist(fptr,plen)
  724.  LVAL fptr; int *plen;
  725. {
  726.     LVAL list,expr,lastnptr,nptr;
  727.     int ch;
  728.  
  729.     /* protect some pointers */
  730.     xlstkcheck(2);
  731.     xlsave(list);
  732.     xlsave(expr);
  733.  
  734.     /* get the open paren */
  735.     if ((ch = nextch(fptr)) != '(')
  736.         xlfail("expecting an open paren");
  737.     xlgetc(fptr);
  738.  
  739.     /* keep appending nodes until a closing paren is found */
  740.     for (lastnptr = NIL, *plen = 0; (ch = nextch(fptr)) != ')'; ) {
  741.  
  742.         /* check for end of file */
  743.         if (ch == EOF)
  744.             badeof(fptr);
  745.  
  746.         /* get the next expression */
  747.         switch (readone(fptr,&expr)) {
  748.         case EOF:
  749.             badeof(fptr);
  750.         case TRUE:
  751.             nptr = consa(expr);
  752.             if (lastnptr == NIL)
  753.                 list = nptr;
  754.             else
  755.                 rplacd(lastnptr,nptr);
  756.             lastnptr = nptr;
  757.             ++(*plen);
  758.             break;
  759.         }
  760.     }
  761.  
  762.     /* skip the closing paren */
  763.     xlgetc(fptr);
  764.  
  765.     /* restore the stack */
  766.     xlpopn(2);
  767.  
  768.     /* return the list */
  769.     return (list);
  770. }
  771.  
  772. /* storech - store a character in the print name buffer */
  773. LOCAL int storech(buf,i,ch)
  774.   char *buf; int i,ch;
  775. {
  776.     if (i < STRMAX)
  777.         buf[i++] = ch;
  778.     return (i);
  779. }
  780.  
  781. /* tentry - get a readtable entry */
  782. LVAL tentry(ch)
  783.   int ch;
  784. {
  785.     LVAL rtable;
  786.     rtable = getvalue(s_rtable);
  787.     if (!vectorp(rtable) || ch < 0 || ch >= getsize(rtable))
  788.         return (NIL);
  789.     return (getelement(rtable,ch));
  790. }
  791.  
  792. /* nextch - look at the next non-blank character */
  793. LOCAL int nextch(fptr)
  794.   LVAL fptr;
  795. {
  796.     int ch;
  797.  
  798.     /* return and save the next non-blank character */
  799.     while ((ch = xlgetc(fptr)) != EOF && isspace(ch))
  800.         ;
  801.     xlungetc(fptr,ch);
  802.     return (ch);
  803. }
  804.  
  805. /* checkeof - get a character and check for end of file */
  806. LOCAL int checkeof(fptr)
  807.   LVAL fptr;
  808. {
  809.     int ch;
  810.  
  811.     if ((ch = xlgetc(fptr)) == EOF)
  812.         badeof(fptr);
  813.     return (ch);
  814. }
  815.  
  816. /* badeof - unexpected eof */
  817. LOCAL VOID badeof(fptr)
  818.   LVAL fptr;
  819. {
  820.     xlgetc(fptr);
  821.     xlfail("unexpected EOF");
  822. }
  823.  
  824. /* isnumber - check if this string is a number */
  825. int isnumber(str,pval)
  826.   char *str; LVAL *pval;
  827. {
  828.     int dl,dr;
  829.     char *p;
  830.  
  831.     /* initialize */
  832.     p = str; dl = dr = 0;
  833.  
  834.     /* check for a sign */
  835.     if (*p == '+' || *p == '-')
  836.         p++;
  837.  
  838.     /* check for a string of digits */
  839.     while (isdigit(*p))
  840.         p++, dl++;
  841.  
  842.     /* check for a decimal point */
  843.     if (*p == '.') {
  844.         p++;
  845.         while (isdigit(*p))
  846.             p++, dr++;
  847.     }
  848.  
  849.     /* check for an exponent */
  850.     if ((dl || dr) && *p == 'E') {
  851.         p++;
  852.  
  853.         /* check for a sign */
  854.         if (*p == '+' || *p == '-')
  855.             p++;
  856.  
  857.         /* check for a string of digits */
  858.         while (isdigit(*p))
  859.             p++, dr++;
  860.     }
  861.  
  862.     /* make sure there was at least one digit and this is the end */
  863.     if ((dl == 0 && dr == 0) || *p)
  864.         return (FALSE);
  865.  
  866.     /* convert the string to an integer and return successfully */
  867.     if (pval) {
  868.         if (*str == '+') ++str;
  869.         if (str[strlen(str)-1] == '.') str[strlen(str)-1] = 0;
  870.         *pval = (dr ? cvflonum(atof(str)) : cvfixnum(ICNV(str)));
  871.     }
  872.     return (TRUE);
  873. }
  874.  
  875. /* defmacro - define a read macro */
  876. #ifdef ANSI
  877. static void defmacro(int ch, LVAL type, int offset)
  878. #else
  879. LOCAL VOID defmacro(ch,type,offset)
  880.   int ch; LVAL type; int offset;
  881. #endif
  882. {
  883.     extern FUNDEF funtab[];
  884.     LVAL subr;
  885.     subr = cvsubr(funtab[offset].fd_subr,funtab[offset].fd_type,offset);
  886.     setelement(getvalue(s_rtable),ch,cons(type,subr));
  887. }
  888.  
  889. /* callmacro - call a read macro */
  890. LOCAL LVAL callmacro(fptr,ch)
  891.   LVAL fptr; int ch;
  892. {
  893.     LVAL *newfp;
  894.  
  895.     /* create the new call frame */
  896.     newfp = xlsp;
  897.     pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  898.     pusharg(cdr(getelement(getvalue(s_rtable),ch)));
  899.     pusharg(cvfixnum((FIXTYPE)2));
  900.     pusharg(fptr);
  901.     pusharg(cvchar(ch));
  902.     xlfp = newfp;
  903.     return (xlapply(2));
  904. }
  905.  
  906. /* upcase - translate a string to upper case */
  907. LOCAL VOID upcase(str)
  908.   char *str;
  909. {
  910.     for (; *str != '\0'; ++str)
  911.         if (islower(*str))
  912.             *str = toupper(*str);
  913. }
  914.  
  915. /* xlrinit - initialize the reader */
  916. VOID xlrinit()
  917. {
  918.     LVAL rtable;
  919.     char *p;
  920.     int ch;
  921.  
  922.     /* create the read table */
  923.     rtable = newvector(256);
  924.     setvalue(s_rtable,rtable);
  925.  
  926.     /* initialize the readtable */
  927.     for (p = WSPACE; (ch = *p++) != 0; )
  928.         setelement(rtable,ch,k_wspace);
  929.     for (p = CONST1; (ch = *p++) != 0; )
  930.         setelement(rtable,ch,k_const);
  931.     for (p = CONST2; (ch = *p++) != 0; )
  932.         setelement(rtable,ch,k_const);
  933.  
  934.     /* setup the escape characters */
  935.     setelement(rtable,'\\',k_sescape);
  936.     setelement(rtable,'|', k_mescape);
  937.  
  938.     /* install the read macros */
  939.     defmacro('#', k_nmacro,FT_RMHASH);
  940.     defmacro('\'',k_tmacro,FT_RMQUOTE);
  941.     defmacro('"', k_tmacro,FT_RMDQUOTE);
  942.     defmacro('`', k_tmacro,FT_RMBQUOTE);
  943.     defmacro(',', k_tmacro,FT_RMCOMMA);
  944.     defmacro('(', k_tmacro,FT_RMLPAR);
  945.     defmacro(')', k_tmacro,FT_RMRPAR);
  946.     defmacro(';', k_tmacro,FT_RMSEMI);
  947. }
  948.  
  949.